home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Franz PD / Franz PD Disk #119 (1991-03)(Amiga User Group Deutschland e.V.).zip / Franz PD Disk #119 (1991-03)(Amiga User Group Deutschland e.V.).adf / AmigaBASIC_Programme / Tortengrafik (.txt) < prev    next >
AmigaBASIC Source Code  |  1989-07-03  |  8KB  |  163 lines
  1. '          *** 3D-Tortengrafik 1.4 ***  © 1990 by Michael Gottwald
  2.  
  3.  DIM Norm%(1),Netz%(1),Schraffur1%(15),Schraffur2%(15),Punkte%(3)
  4.  DIM Punkte2%(3),Punkte3%(3),Punkte4%(3),Punkte5%(3),Streifen%(1)
  5.  DIM Balken%(1),Netz2%(3):Norm%(0)=&Hffff:Norm%(1)=&Hffff
  6.  Netz%(0)=&Haaaa:Netz%(1)=&H5555:FOR i%=0 TO 15:READ d%:Schraffur1%(i%)=d%
  7.  Schraffur2%(15-i%)=d%:NEXT:Punkte%(0)=&H9248:Punkte%(2)=&H4924
  8.  Punkte2%(1)=&H9248:Punkte3%(0)=&H8208:Punkte3%(3)=&H1041
  9.  Punkte4%(0)=&H8010:Punkte4%(3)=&H801:Punkte5%(1)=&H800:Punkte5%(2)=8
  10.  Streifen%(0)=&Haaaa:Streifen%(1)=&Haaaa:Balken%(0)=&Hffff
  11.  Netz2%(0)=&Haaaa:Netz2%(2)=&H5555
  12.  
  13.  x=150:y=74:c=3:c2=2:a=2
  14.  t$="MedRes 1         640x242 ,  6 Farben + 4 Muster":Text
  15.  y=94:t$="MedRes 2         640x242 , 14 Farben + 4 Muster":Text
  16.  y=114:t$="Hires 1          640x498 ,  6 Farben + 4 Muster":Text
  17.  y=134:t$="Hires 2          640x498 , 14 Farben + 4 Muster":Text
  18.  y=154:t$="Monochrom 1      640x242 ,  1 Farbe + 12 Muster":Text
  19.  y=174:t$="Monochrom 2      640x498 ,  1 Farbe + 12 Muster":Text
  20.  FOR y%=63 TO 163 STEP 20:LINE (100,y%)-(100,y%+16),1:LINE -(140,y%+16),2
  21.  LINE -(140,y%),2:LINE -(100,y%),1:NEXT:LOCATE 28,2:COLOR 2,0
  22.  PRINT "Monochrom 1/2 ist für eine Hardcopy mit einem S/W-Drucker ";
  23.  PRINT "am sinnvollsten !"
  24.  
  25. Gadgets: CALL Maus (x,y):IF x<100 OR  x>140 THEN Gadgets
  26.            IF y>62  AND y<79  THEN Hoehe=242:Tiefe=3:Modus=2:q=30:GOTO Haupt
  27.            IF y>82  AND y<99  THEN Hoehe=242:Tiefe=4:Modus=2:q=70:GOTO Haupt
  28.            IF y>102 AND y<119 THEN Hoehe=498:Tiefe=3:Modus=4:q=30:GOTO Haupt
  29.            IF y>122 AND y<139 THEN Hoehe=498:Tiefe=4:Modus=4:q=70:GOTO Haupt
  30.            IF y>142 AND y<159 THEN Hoehe=242:Tiefe=3:Modus=2:q=12:GOTO Haupt
  31.            IF y>162 AND y<179 THEN Hoehe=498:Tiefe=3:Modus=4:q=12:GOTO Haupt
  32.          GOTO Gadgets                
  33.  
  34. Haupt: SCREEN 1,640,Hoehe+14,Tiefe,Modus
  35.  w$=SPACE$(26)+"© 199O by Michael Gottwald":WINDOW 1,w$,(0,0)-(630,Hoehe),4,1
  36.  WINDOW 1
  37.  PALETTE 0,0,0.6,0.7:PALETTE 1,0,0,0:PALETTE 2,0.8,0.8,0:PALETTE 3,0,1,0
  38.  PALETTE 4,1,0,0:PALETTE 5,0,0,1:PALETTE 6,1,0,1:PALETTE 7,1,1,1
  39.  DIM p(70),w$(70),c(70,5)
  40. Start: COLOR ,0:CLS:LOCATE 2,30:a=2:x=252:y=12:c=2:c2=0:t$="3D-Tortengrafik"
  41.  CALL Text:LOCATE 6,3:COLOR 1,0:LINE (244,4)-(244,16),7
  42.  LINE -(380,16),1:LINE -(380,4),1:LINE -(244,4),7:x=16:y=60:c=3
  43.  LINE (240,2)-(240,18),7:LINE -(384,18),1:LINE -(384,2),1:LINE -(240,2),7
  44.  t$="Dieses Programm erzeugt eine dreidimensionale Tortengrafik.":CALL Text
  45.  y=y+10:t$="Es kann bis zu 70 verschiedene Segmente einer Scheibe nach"
  46.  t$=t$+" prozentualer":CALL Text:y=y+10:t$="Einteilung zeichnen.":CALL Text
  47.  y=y+50:x=176:a=1:c=4:t$="© 199O written by Michael Gottwald"
  48.  CALL Text:LINE (128,120)-(128,136),1:LINE -(496,136),7:LINE -(496,120),7
  49.  LINE -(128,120),1:y=y+50:x=196:c=5
  50.  t$="...Linke Maustaste drücken...":CALL Text:WHILE MOUSE(0)=0:WEND
  51. Frage: LINE (0,18)-(630,200),0,bf:c=2:x=8:y=30:a=2:z=0:s=0:pi=5.30795e-315
  52.  t$="(P)rozentwerte oder (B)eliebige Zahlen ? ":Text
  53.  INPUT f$:f$=UCASE$(f$):IF f$="P" THEN Prozente
  54.                         IF f$="B" THEN Beliebig
  55.  GOTO Frage
  56. Beliebig: LINE (0,18)-(630,200),0,bf:c=2:x=8:y=30:a=2:z=0  
  57.  t$="Bitte die Zahlen eingeben.- Maximal"+STR$(q)+" !":CALL Text:y=y+10
  58.  t$=" 0 = Ende !":LOCATE 8:COLOR 3
  59. BelZahl: GOSUB Eingabe:z=z+1:IF z>q THEN PRINT"Zuviel Zahlen !":GOTO Beliebig
  60.          s=s+x:p(z)=x:IF x<>0 THEN BelZahl
  61.          z=z-1:PRINT:INPUT "Was soll hinter einer Zahl stehen ";k$:GOTO Torte
  62. Prozente: LINE (0,18)-(630,200),0,bf:c=2:x=8:y=30:a=2
  63.  t$="Bitte die Zahlen eingeben.- Maximal"+STR$(q)+" !":CALL Text:y=y+10
  64.  t$="Die Summe aller darf 100 natürlich nicht überschreiten !":CALL Text
  65.  y=y+10:t$="0 = Ende !":CALL Text:LOCATE 8:COLOR 3
  66. ProzZahl: GOSUB Eingabe:IF x+s=100 THEN s=s+x:p(z)=x:z=z+1:k$="%":GOTO Torte
  67.         IF x=0 OR s+x>100 OR x>100 THEN ProzZahl
  68.        s=s+x:p(z)=x:z=z+1:IF z<q THEN ProzZahl    
  69. Eingabe: PRINT " Zahl Nr."z+1;":  (Summe bisher:"s;:IF f$="P" THEN PRINT"%";
  70.          PRINT ")";
  71. Wort:   INPUT " ";x:COLOR 5:INPUT "Text dazu (max. 10 Zeichen): ",w$(z)
  72.         IF LEN(w$(z))>10 THEN Wort :ELSE COLOR 3:RETURN
  73.  
  74. Torte: IF q=12 THEN
  75.          SCREEN 1,640,256,1,Modus:WINDOW 1,w$,(0,0)-(630,Hoehe),4,1      
  76.          WINDOW 1:PALETTE 0,1,1,1:PALETTE 1,0,0,0
  77.        END IF  
  78.   CLS:z=z-1:CIRCLE (320,120),200,1,pi,2*pi,0.2:LINE (120,100)-(120,120),1
  79.   LINE (520,100)-(520,120),1:CIRCLE (320,100),200,1,,,0.2
  80.   sw=0:c=1:PATTERN &Hffff,Norm%:FOR i=0 TO z
  81.   IF q=12 THEN
  82.    c=1:ON i GOTO M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,12
  83.   END IF 
  84.   IF q=30 THEN IF (i+1)/7=INT((i+1)/7) THEN c=1:Nr=(i+1)/7:GOTO Muster
  85.   IF q=70 THEN IF (i+1)/15=INT((i+1)/15) THEN c=1:Nr=(i+1)/15:GOTO Muster
  86.   GOTO Seg
  87. Muster: ON Nr GOTO M1,M4,M5,M6
  88. Seg: GOSUB Segment:c=c+1:NEXT:PATTERN &H71ce
  89.    a=2:FOR i=0 TO z:c=7:LINE (c(i,0),c(i,1))-(c(i,2),c(i,3)),1
  90.    y=c(i,3):IF y>c(i,1) THEN y=y-5
  91.    t$=w$(i):IF c(i,2)<c(i,0) THEN                              
  92.               x=(c(i,2)-(LEN(w$(i))*8))
  93.               IF q=12 THEN CALL MText :ELSE CALL Text
  94.               GOTO Ok
  95.             END IF  
  96.    x=c(i,2):IF q=12 THEN CALL MText :ELSE CALL Text
  97. Ok: y=y+10:x=x-8:IF c(i,2)<c(i,0) THEN x=x+8-LEN(k$)*8
  98.     c=2:t$=STR$(p(i))+k$:IF q=12 THEN CALL MText :ELSE CALL Text
  99.    NEXT:PATTERN &Hffff,Norm%:GOTO Gadget
  100.                
  101. Segment:
  102.   IF f$="B" THEN p=(p(i)/s)*100 :ELSE p=p(i)
  103.   w=sw+(360*p/100):ew=w*pi/180:fs=sw:sw=sw*pi/180:z1=320+SIN(sw)*200
  104.    z2=100+COS(sw)*40:z3=320+SIN(ew)*200:z4=100+COS(ew)*40
  105.     LINE (320,100)-(z1,z2),1:LINE (320,100)-(z3,z4),1 
  106.      M=(ew-sw)/2:M=ew-M:PAINT (320+SIN(M)*198,100+COS(M)*38),c,1
  107.       f=0:ff=0:IF fs>=0 AND fs<=89 OR fs>270 AND fs<=360 THEN f=1
  108.       IF w>=0 AND w<=89 OR w>270 AND w<=360 THEN ff=1
  109.       IF f=1 OR ff=1 THEN GOSUB Front
  110.      a=sw+0.5*(ew-sw):sw=w
  111.      c(i,0)=320+SIN(a)*180:c(i,1)=100+COS(a)*30
  112.      c(i,2)=320+SIN(a)*235:c(i,3)=100+COS(a)*80
  113.      IF a>1.56 AND a<4.72 THEN c(i,3)=100+COS(a)*60
  114.   RETURN           
  115. Front: IF w>=0 AND w<=89 OR w>270 AND w<=360 THEN LINE (z3,z4)-(z3,z4+20),1
  116.     IF fs>=0 AND fs<=89 OR fs>270 AND fs<=360 THEN LINE (z1,z2)-(z1,z2+20),1
  117.     IF f=1 THEN GOSUB Sangle   
  118.     IF ff=1 THEN GOSUB Eangle
  119.   RETURN
  120. Sangle: PAINT (z1+1,z2+1),c,1:RETURN
  121. Eangle: PAINT (z3-1,z4+1),c,1:RETURN  
  122.  
  123. Gadget: c1=7:c2=1:ct1=3:ct2=4:IF q=12 THEN c1=1
  124.         x=28:y=14:a=1:c=ct2:t$="Ende":IF q=12 THEN CALL MText :ELSE CALL Text
  125.         LINE (20,4)-(20,20),c1:LINE -(68,20),c2:LINE -(68,4),1
  126.         LINE -(20,4),c1:y=34:x=16:c=ct1:t$="Nochmal":LINE (8,24)-(8,40),c1
  127.         IF q=12 THEN CALL MText :ELSE CALL Text
  128.         LINE -(79,40),c2:LINE -(79,24),c2:LINE -(8,24),c1
  129. check: CALL Maus (x,y):IF x>19 AND x<69 AND y>3 AND y<21 THEN LOCATE 10:END       
  130.        IF x>7 AND x<80 AND y>23 AND y<41 AND q=12 THEN RUN
  131.        IF x>7 AND x<80 AND y>23 AND y<41 THEN Start
  132.       GOTO check
  133.  
  134. SUB Text STATIC
  135.  SHARED x,y,c,c2,a,t$           ' a ist der x-Abstand des Schattens
  136.  POKEW WINDOW(8)+38,y+1:COLOR c2,0:PRINT PTAB(x+a);t$:POKE WINDOW(8)+28,0
  137.  POKEW WINDOW(8)+38,y:COLOR c:PRINT PTAB(x);t$:POKE WINDOW(8)+28,1
  138. END SUB
  139.  
  140. SUB Maus (x,y) STATIC
  141.  WHILE MOUSE(0)=0:WEND:x=MOUSE(3):y=MOUSE(4):WHILE MOUSE(0)<>0:WEND
  142. END SUB 
  143.  
  144. SUB MText STATIC                ' Füür Monochrom-Modus...
  145.  SHARED x,y,t$
  146.  POKEW WINDOW(8)+38,y:COLOR 1:PRINT PTAB(x);t$
  147. END SUB   
  148.                    'Schraffur 1:
  149.      DATA &H9249,&H4924,&H2492,&H9249,&H4924,&H2492    
  150.      DATA &H9249,&H4924,&H2492,&H9249,&H4924,&H2492
  151.      DATA &H9249,&H4924,&H2492,&H9249
  152. M1:  PATTERN ,Netz%:GOTO Seg
  153. M2:  PATTERN ,Streifen%:GOTO Seg
  154. M3:  PATTERN ,Balken%:GOTO Seg
  155. M4:  PATTERN ,Schraffur1%:GOTO Seg
  156. M5:  PATTERN ,Schraffur2%:GOTO Seg
  157. M6:  PATTERN ,Netz2%:GOTO Seg
  158. M7:  PATTERN ,Punkte%:GOTO Seg
  159. M8:  PATTERN ,Punkte2%:GOTO Seg
  160. M9:  PATTERN ,Punkte3%:GOTO Seg
  161. M10: PATTERN ,Punkte4%:GOTO Seg
  162. M11: PATTERN ,Punkte5%:GOTO Seg
  163.